﻿Option Explicit On

Public Class regOp

    'DefStr S
    'DefLng H-I, L, N
    'DefVar V
    'DefBool B

    Private Structure OSVERSIONINFO
        Dim dwOSVersionInfoSize As Long
        Dim dwMajorVersion As Long
        Dim dwMinorVersion As Long
        Dim dwBuildNumber As Long
        Dim dwPlatformId As Long
        Dim szCSDVersion As String
    End Structure

    Private Structure SECURITY_ATTRIBUTES
        Dim nLength As Long
        Dim lpSecurityDescriptor As Long
        Dim bInheritHandle As Long
    End Structure

    ' RegCreateKeyEx creates the specified key. If the key already exists,
    ' the function opens it. The phkResult parameter receives the key handle.
    Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" ( _
      ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, _
      ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, _
      ByVal lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal phkResult As Long, _
      ByVal lpdwDisposition As Long) As Long

    ' RegCloseKey releases a handle to the specified key.
    ' (Key handles should not be left open any longer than necessary.)
    Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hCurKey As Long) As Long

    ' RegQueryInfoKey retrieves information about the specified key,
    ' such as the number of subkeys and values, the length of the
    ' longest value and key name, and the size of the longest data
    ' component among the key's values.
    Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" ( _
      ByVal hCurKey As Long, ByVal lpClass As String, ByVal lpcbClass As Long, _
      ByVal lpReserved As Long, ByVal lpcSubKeys As Long, ByVal lpcbMaxSubKeyLen As Long, _
      ByVal lpcbMaxClassLen As Long, ByVal lpcValues As Long, ByVal lpcbMaxValueNameLen As Long, _
      ByVal lpcbMaxValueLen As Long, ByVal lpcbSecurityDescriptor As Long, _
      ByVal lpftLastWriteTime As Long) As Long

    ' RegEnumKeyEx enumerates subkeys of the specified open key.
    ' Retrieves the name (and its length) of each subkey.
    Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" ( _
      ByVal hCurKey As Long, ByVal dwIndex As Long, ByVal lpName As String, _
      ByVal lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, _
      ByVal lpcbClass As Long, ByVal lpftLastWriteTime As Long) As Long

    ' RegEnumValue enumerates the values for the specified open key.
    ' Retrieves the name (and its length) of each value, and the type,
    ' content and size of the data.
    Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" ( _
      ByVal hCurKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, _
      ByVal lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, _
      ByVal lpData As Object, ByVal lpcbData As Long) As Long

    ' RegQueryValueEx retrieves the type, content and data for a specified value name.
    ' Note that if you declare the lpData parameter as String, you must pass it By Value.
    Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
      ByVal hCurKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
      ByVal lpType As Long, ByVal lpData As Object, ByVal lpcbData As Long) As Long

    ' RegSetValueEx sets the data and type of a specified value under a key.
    Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" ( _
      ByVal hCurKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
      ByVal dwType As Long, ByVal lpData As Object, ByVal cbData As Long) As Long

    ' RegDeleteValue removes a named value from the specified key.
    Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" ( _
      ByVal hCurKey As Long, ByVal lpValueName As String) As Long

    ' RegDeleteKey deletes a subkey. Under Win 95/98, also deletes all
    ' subkeys and values. Under Windows NT/2000, the subkey to be deleted
    ' must not have subkeys. The class attempts to use SHDeleteKey (see below)
    ' before using RegDeleteKey.
    Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" ( _
      ByVal hKey As Long, ByVal lpSubKey As String) As Long

    ' SHDeleteKey deletes a subkey and all its descendants.
    ' Under Windows NT 4.0, Internet Explorer 4.0 or later is required.
    Private Declare Function SHDeleteKey Lib "Shlwapi" Alias "SHDeleteKeyA" ( _
        ByVal hKey As Long, ByVal lpSubKey As String) As Long

    Private Declare Function LoadLibrary Lib "Kernel32" Alias "LoadLibraryA" ( _
      ByVal lpLibFileName As String) As Long

    Private Declare Function FreeLibrary Lib "Kernel32" (ByVal hLibModule As Long) As Long

    Private Declare Function ExpandEnvStrings Lib "Kernel32" Alias _
      "ExpandEnvironmentStringsA" (ByVal lpSrc As String, ByVal lpDst As String, _
      ByVal nSize As Long) As Long

    Private Declare Function GetVersionEx Lib "Kernel32" Alias _
        "GetVersionExA" (ByVal lpVersionInformation As OSVERSIONINFO) As Long

    Private Const REG_SZ = 1
    Private Const REG_EXPAND_SZ = 2
    Private Const REG_DWORD = 4
    Private Const REG_DWORD_LITTLE_ENDIAN = REG_DWORD
    Private Const REG_MULTI_SZ = 7

    ' The following values are only relevant under WinNT/2K,
    ' and are ignored by Win9x:
    Private Const STANDARD_RIGHTS_READ = &H20000
    Private Const STANDARD_RIGHTS_WRITE = &H20000
    Private Const STANDARD_RIGHTS_ALL = &H1F0000
    Private Const KEY_CREATE_LINK = &H20
    Private Const KEY_QUERY_VALUE = &H1
    Private Const KEY_ENUMERATE_SUB_KEYS = &H8
    Private Const KEY_NOTIFY = &H10
    Private Const KEY_SET_VALUE = &H2
    Private Const KEY_CREATE_SUB_KEY = &H4
    Private Const SYNCHRONIZE = &H100000

    'Access right to query and enumerate values:
    Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
      KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or _
      KEY_NOTIFY) And (Not SYNCHRONIZE))
    'Access right to create values and keys:
    Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or _
      KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
    'Access right to create/delete values and keys:
    Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
      KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or _
      KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) _
      And (Not SYNCHRONIZE))

    Private lRequiredAccess
    Private lPreviousAccess

    ' Return values for all Registry functions:
    Private Const ERROR_SUCCESS = 0

    'Property variables:
    Private lRoot 'default is HKEY_LOCAL_MACHINE
    Private lOptions
    Private strKeyName
    Private strValueName
    Private vData

    ' Variables set in GetKeyHandle:
    Private hCurKey
    Private nSubKeys
    Private nValues
    Private lMaxSubKeyLen
    Private lMaxValueNameLen
    Private lMaxValueLen

    Private bIsWinNT

    Public Enum RegOptions 'variable: lOptions
        StoreNumbersAsStrings = 1
        ReturnMultiStringsAsArrays = 2
        ExpandEnvironmentStrings = 4
        ShowErrorMessages = 8
    End Enum

    Public Enum RegRoot 'variable: lRoot
        HKEY_CLASSES_ROOT = &H80000000
        HKEY_CURRENT_USER = &H80000001  'default
        HKEY_LOCAL_MACHINE = &H80000002
    End Enum

    ' Message constants:
    Private Const ERROR_NO_KEY As String = _
      "No Key name specified!"
    Private Const ERROR_NO_HANDLE = _
      "Could not open Registry Key!"
    Private Const ERR_MSG_NO_OVERWRITE As String = _
      "Existing value has unsupported data type " & _
        "and will not be overwritten"
    Private Const RETURN_UNSUPPORTED As String = _
      "(unsupported data format)"

    Private ValueList As Object

    WriteOnly Property Root() As RegRoot

        Set(ByVal lProp As RegRoot)

            Select Case lProp
                Case regOp.RegRoot.HKEY_CLASSES_ROOT, regOp.RegRoot.HKEY_CURRENT_USER, _
                  regOp.RegRoot.HKEY_LOCAL_MACHINE
                    'all is well
                Case Else
                    lRoot = regOp.RegRoot.HKEY_CURRENT_USER
            End Select
            If lProp <> lRoot Then
                lRoot = lProp
                If Len(strKeyName) Then
                    GetKeyHandle(lRoot, strKeyName)
                End If
            End If
            lRoot = lProp

        End Set

    End Property

    WriteOnly Property Key()

        Set(ByVal strProp)
            If Len(strProp) = 0 Then Exit Property
            If Len(strKeyName) = 0 Then 'first time
                strKeyName = strProp
            ElseIf StrComp(strProp, strKeyName, vbTextCompare) <> 0 Then
                strKeyName = strProp
                GetKeyHandle(lRoot, strKeyName)
            Else
            End If
        End Set
    End Property

    Property Options() As RegOptions
        Get

        End Get
        Set(ByVal lProp As RegOptions)
            Select Case lProp
                Case 0 To 15 : lOptions = lProp
                Case Else : End Select
        End Set
    End Property
    'Don't accept an invalid Options value:
    Property Value(Optional ByVal ValueName As String = "", Optional ByVal ValueVal As String = "")
        Get
            With ValueList
                If .Count = 0 Then FillDataList(ValueName)
                If .Exists(ValueName) Then Value = .Item(ValueName)
            End With
        End Get
        Set(ByVal vValue)
            RegSetValueEx(hCurKey, ValueName, 0, REG_EXPAND_SZ, CStr(vData), Len(vData) + 1)
        End Set
    End Property


    Function DeleteValue(Optional ByVal ValueName As String = "") As Boolean

        If bIsWinNT Then lRequiredAccess = KEY_ALL_ACCESS

        If PropertiesOK() Then
            DeleteValue = (RegDeleteValue(hCurKey, ValueName) = ERROR_SUCCESS)
            ' Update Value Count:
            If DeleteValue Then
                Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, 0, _
                  0, 0, nValues, 0, 0, 0, 0)
                ' Empty the database:
                ValueList.RemoveAll()
            End If
        End If
    End Function


    Function DeleteKey() As Boolean
        If Len(strKeyName) = 0 Then ShowErrMsg(ERROR_NO_KEY) : Exit Function

        Dim n, strLastKey
        n = InStrRev(strKeyName, "\")
        If n > 0 And n < Len(strKeyName) Then
            strLastKey = Mid$(strKeyName, n + 1)
            strKeyName = Utils.Left(strKeyName, n - 1)

            If bIsWinNT Then lRequiredAccess = KEY_ALL_ACCESS

            Call GetKeyHandle(lRoot, strKeyName)
            If hCurKey = 0 Then Exit Function
            If ShlwapiInstalled() Then
                ' this should always work:
                DeleteKey = (SHDeleteKey(hCurKey, strLastKey) = ERROR_SUCCESS)
            Else
                ' this will only work under Win95/98:
                DeleteKey = (RegDeleteKey(hCurKey, strLastKey) = ERROR_SUCCESS)
            End If
            'Update Key and Value Count:
            If DeleteKey Then
                Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, nSubKeys, _
                  0, 0, 0, 0, 0, 0, 0)
                ValueList.RemoveAll()
            End If
        End If

    End Function

    Private Function PropertiesOK() As Boolean
        If Len(strKeyName) = 0 Then ShowErrMsg(ERROR_NO_KEY) : Exit Function
        If lPreviousAccess Then
            If lRequiredAccess <> lPreviousAccess Then CloseCurrentKey()
        End If
        If hCurKey = 0 Then Call GetKeyHandle(lRoot, strKeyName)
        If hCurKey = 0 Then ShowErrMsg(ERROR_NO_HANDLE) : Exit Function
        PropertiesOK = True
    End Function

    Private Sub Class_Initialize()
        lRoot = RegRoot.HKEY_CURRENT_USER
        bIsWinNT = IsWinNT()
        If bIsWinNT Then lRequiredAccess = KEY_READ

        On Error Resume Next
        ValueList = CreateObject("Scripting.Dictionary")
        ValueList.CompareMode = vbTextCompare

    End Sub

    Private Sub Class_Terminate()
        CloseCurrentKey()
        ValueList = Nothing
    End Sub

    Private Sub CloseCurrentKey()
        If hCurKey Then
            Call RegCloseKey(hCurKey)
            hCurKey = 0
        End If
    End Sub

    Private Sub GetKeyHandle(ByVal lKey, ByVal strKey)
        CloseCurrentKey()
        If lKey = 0 Then lKey = RegRoot.HKEY_CURRENT_USER
        Dim SA As SECURITY_ATTRIBUTES
        Call RegCreateKeyEx(lKey, strKey, 0, vbNull, 0, _
          lRequiredAccess, SA, hCurKey, 0)
        If hCurKey Then
            Call RegQueryInfoKey(hCurKey, vbNullString, 0, 0, nSubKeys, _
              lMaxSubKeyLen, 0, nValues, lMaxValueNameLen, lMaxValueLen, _
              0, 0)
            ValueList.RemoveAll()
            lPreviousAccess = lRequiredAccess
        End If
    End Sub

    Private Function TrimNull(ByVal strIn) As String
        TrimNull = Utils.Left(strIn, InStr(strIn, vbNullChar) - 1)
    End Function

    Private Function TrimDoubleNull(ByVal strIn) As String
        'If Len(strIn) Then TrimDoubleNull = _
        ' Utils.Left(strIn, InStr(strIn, String$(2, 0)) - 1)
        Throw New NotImplementedException
    End Function

    Private Function ExpandString(ByVal strIn) As String
        'Dim nChars, strBuff, nBuffSize
        'nBuffSize = 1024
        'strBuff = String$(nBuffSize, 0)
        'nChars = ExpandEnvStrings(strIn, strBuff, nBuffSize)
        'If nChars Then ExpandString = Utils.Left(strBuff, nChars - 1)
        Throw New NotImplementedException
    End Function

    Private Function ShlwapiInstalled() As Boolean
        Dim hLib As Long
        hLib = LoadLibrary("Shlwapi")
        If hLib Then
            ShlwapiInstalled = True
            FreeLibrary(hLib)
        End If
    End Function

    Private Function ContainsEnvString(ByVal strTest) As Boolean
        'Const PCT As String = "%"
        '' see if there is a percent sign
        'Dim n As Long : n = InStr(strTest, PCT)
        'If n = 0 Then Exit Function
        '' see if there is a second percent sign
        'If n = InStrRev(strTest, PCT) Then Exit Function
        ''now we have a potential environment string
        'Dim Env As String, EnvSplit() As String
        'Dim i As Long
        'For i = 1 To 100
        '    Env = Environ(i)
        '    If Len(Env) Then
        '        EnvSplit = Split(Env, "=")
        '        If InStr(1, strTest, PCT & EnvSplit(0) & PCT, vbTextCompare) Then
        '            ContainsEnvString = True
        '            Exit For
        '        End If
        '    Else
        '        Exit For
        '    End If
        'Next
        Throw New NotImplementedException
    End Function

    Private Sub ShowErrMsg(ByVal strMsg)
        'If (lOptions And ShowErrorMessages) Then
        '    MsgBox(strMsg, vbExclamation, "Registry Error")
        'Else
        '    Debug.Print(strMsg)
        'End If
        Throw New NotImplementedException
    End Sub

    Private Function IsWinNT()
        'Returns True if the OS is Windows NT/2000
        Const VER_PLATFORM_WIN32_NT As Long = 2
        Dim osvi As OSVERSIONINFO
        osvi.dwOSVersionInfoSize = Len(osvi)
        GetVersionEx(osvi)
        IsWinNT = (osvi.dwPlatformId = VER_PLATFORM_WIN32_NT)
    End Function

    Private Sub FillDataList(Optional ByVal Key As String = "")
        '    If Len(Key) Then strKeyName = Key
        '    If Len(strKeyName) = 0 Then ShowErrMsg(ERROR_NO_KEY) : Exit Sub

        '    If bIsWinNT Then lRequiredAccess = KEY_READ

        '    If PropertiesOK() Then
        '        If nValues = 0 Then Exit Sub

        '        ValueList.RemoveAll()

        '        Dim i, lValuename, lType, lBuffer, strValue, strBuffer
        '        For i = 0 To nValues - 1
        '            lValuename = lMaxValueNameLen + 1
        '            strValue = String$(lValuename, 0)
        '            lBuffer = lMaxValueLen + 1
        '            strBuffer = String$(lBuffer, 0)
        'If RegEnumValue(hCurKey, i, strValue, lValuename, 0, lType, _
        '  ByVal strBuffer, lBuffer) = ERROR_SUCCESS Then
        '                strValue = TrimNull(strValue)
        '                Select Case lType
        '                    Case REG_SZ
        '                        ValueList(strValue) = TrimNull(strBuffer)
        '                    Case REG_EXPAND_SZ
        '                        If (lOptions And RegOptions.ExpandEnvironmentStrings) Then
        '                            ValueList(strValue) = ExpandString(TrimNull(strBuffer))
        '                        Else
        '                            ValueList(strValue) = TrimNull(strBuffer)
        '                        End If
        '                    Case REG_MULTI_SZ
        '                        If (lOptions And RegOptions.ReturnMultiStringsAsArrays) Then
        '                            ValueList(strValue) = Split(TrimDoubleNull(strBuffer), vbNullChar)
        '                        Else
        '                            ValueList(strValue) = TrimDoubleNull(strBuffer)
        '                        End If
        '                    Case REG_DWORD, REG_DWORD_LITTLE_ENDIAN
        '                        Dim nBuffer
        '                        If RegEnumValue(hCurKey, i, strValue, Len(strValue) + 1, _
        '                          0, REG_DWORD, nBuffer, 4) = ERROR_SUCCESS Then
        '                            ValueList(strValue) = nBuffer
        '                        End If
        '                    Case Else
        '                        ValueList(strValue) = RETURN_UNSUPPORTED
        '                End Select
        '            End If
        '        Next

        '    End If
        Throw New NotImplementedException
    End Sub

End Class
